Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE02/TPACK/TPACK.ZIP/USERWIN.PAS

Pascal/Delphi Source File | 1995-06-01 | 12.0 KB | 344 lines

{------------------------------------------------------------------------------}
{UNREGISTERED VERSION (6/1/95) PLEASE REDISTRIBUTE IN tPACK.ZIP!
 This revision does not contain everything, nor are the exciting
 DataSetReporter and ExtendedMenu[Item] components included.
 Use SWREG#5906 to receive these, icons and a help file for $130.
 You must register when using this code in a business application!
 You'll receive a license to use this code in up to 50 copies of
 any app you write. In turn you will get responsive e-mail
 tech support and enhancements till I run out of registrations
 or suggestions. Meanwhile.. enjoy the code. Bye! I'll make more.
 {(C)'1995 Michael/Ax-Systems, 71560,[e-mail]}
{------------------------------------------------------------------------------}

unit UserWin;

{-----------------------------------------------------------------------------------------}
{ USERWIN                                                                                 }
{-----------------------------------------------------------------------------------------}

interface

uses
  Classes,
  UserInfo;

function TrailingChar(Value:String;Trailer:Char):String; {insures a trailing character}
function TrailingBackSlash(Value:String):String;         {insures a trailing '\'}

Type
  TWindowsUserInfo = class(TUserInfo)
  {service component to get some windows info as well as unique files that can be automatically
  zapped when the component shuts down. it can also validate a password against the screen saver}
  private
    fUserName,
    fCompanyName,
    fPassWord       : PString;
    fSsDelay        : Integer;
    fZap            : Boolean;
    fUniqueNames    : TStringList;
  protected
    procedure WinEncrypt(Strg: PChar);
    Procedure EncryptCString(S: PChar);
    Function  EncryptString(const S: String): String;
    function GetUserName:String;
    function GetCompanyName:String;
    function GetWindowsPath:String;
    function GetSystemPath:String;
    function GetFreeGDI: integer;
    function GetFreeUser: integer;
    function GetFreeSystem: integer;
    function GetUniqueFileName:String;
    function GetFreeSpace: longint;
    procedure SetNoLongInt(Value:LongInt);
    procedure SetNoInteger(Value:Integer);
    procedure SetNoString(const Value:String);
  public
    Constructor Create(aOwner:TComponent); Override;
    Destructor Destroy; Override;
    function UpdateOK: boolean; Override;
    Function HasPassWord:Boolean;
    Function CheckPassWord(const Value:String):Boolean;
    property UniqueFileName: String read GetUniqueFileName;
  published
    property ZapUniqueOnFree:Boolean read fZap write fZap default true;
    property UserName: String read GetUserName write SetNoString stored false;
    property CompanyName: String read GetCompanyName write SetNoString stored false;
    property SaverDelay: Integer read fssDelay write SetNoInteger stored false;
    property WindowsPath: String read GetWindowsPath write SetNoString stored false;
    property SystemPath: String read GetSystemPath write SetNoString stored false;
    property FreeSpace: Longint read GetFreeSpace write SetNoLongInt stored false;
    property FreeGDI: integer read GetFreeGDI write SetNoInteger stored false;
    property FreeUser: integer read GetFreeUser write SetNoInteger stored false;
    property FreeSystem: integer read GetFreeSystem write SetNoInteger stored false;
    end;

implementation

uses
  IniFiles
  ,PasUtils
  ,WinTypes
  ,WinProcs
  ,Controls
  ,SysUtils;

const
  BufSize = 144;

{------------------------------------------------------------------------------}
{ TRAILING CHARACTER, TRAILING BACKSLASH                                       }
{------------------------------------------------------------------------------}
{need to include a StringServices component perhaps} {for now these utils are here.}

function TrailingChar(Value:String;Trailer:Char):String; {insures a trailing character}
begin
  Result:=Value;
  if copy(Value,length(Value),1)<>Trailer then
    Result:=Result+Trailer;
end;

function TrailingBackSlash(Value:String):String; {insures a trailing '\'}
begin
  if Value<>'' then
    Result:=TrailingChar(Value,'\')
  else
    Result:=Value;
end;

{-----------------------------------------------------------------------------------------}
{ OBJECT CREATION                                                                         }
{-----------------------------------------------------------------------------------------}

Constructor TWindowsUserInfo.Create(aOwner:TComponent);
begin
  inherited Create(aOwner);
{  Options:=[uifUpdateOnLoad,uifUpdateOnGet];  }
  fUserName:=NullStr;
  fCompanyName:=NullStr;
  fPassWord:=NullStr;
  fUniqueNames:=TStringList.Create;
  fZap:=True;
end;

Destructor TWindowsUserInfo.Destroy;
var
  i,n:longint;
begin
  with fUniqueNames do begin
    n:=Count-1;
    if fZap and (n>-1) then
      for i:=0 to n do
        if FileExists(Strings[i]) then
          DeleteFile(Strings[i]);
    Free;
    end;
  DisposeStr(fUserName);
  DisposeStr(fCompanyName);
  DisposeStr(fPassWord);
  inherited Destroy;
end;

function TWindowsUserInfo.UpdateOK: boolean;
var
  Ini:TIniFile;
  fileHandle: THandle;
  zStr:PChar;
begin
  Result:=inherited UpdateOK;
  if not Result then
    Exit;
  Ini := TIniFile.Create('CONTROL.INI');                         { Open the Ini File }
  AssignStr(fPassword,Ini.ReadString('ScreenSaver','Password',''));{ Read the Password }
  Ini.Free;                                                      { Close It }
  SystemParametersInfo(SPI_GETSCREENSAVETIMEOUT,0,@fSsDelay,0);  { Read the Delay }
  if fSsDelay > 0 then fSsDelay := fSsDelay Div 60;              { Get Minutes }
  if fSsDelay = 0 then fSsDelay := 1;                            { JIC an awkward Number }
  { Get user name and company name }                               {what did he mean there?}
  fileHandle := LoadLibrary('USER');
  if fileHandle >= HINSTANCE_ERROR then begin
    zStr:=MakePChar('');
    If LoadString(fileHandle, 514, zStr, 255) <> 0 Then
      AssignStr(fUserName,StrPas(zStr));
    If LoadString(fileHandle, 515, zStr, 255) <> 0 Then
      AssignStr(fCompanyName,StrPas(zStr));
    FreeLibrary(fileHandle);
    end;
end;

{-----------------------------------------------------------------------------------------}
{ OBJECT PLUMBING                                                                         }
{-----------------------------------------------------------------------------------------}

procedure TWindowsUserInfo.SetNoLongInt(Value:LongInt);
begin
end;

procedure TWindowsUserInfo.SetNoInteger(Value:Integer);
begin
end;

procedure TWindowsUserInfo.SetNoString(const Value:String);
begin
end;

function TWindowsUserInfo.GetWindowsPath:String;
var
  Buffer: PChar;
  Count: Word;
begin
  GetMem(Buffer, BufSize);
  Count:=GetWindowsDirectory(Buffer,BufSize);
  Result:=strpas(Buffer);
  FreeMem(Buffer, BufSize);
  Result:=TrailingBackSlash(Result);
end;

function TWindowsUserInfo.GetSystemPath:String;
var
  Buffer: PChar;
  Count: Word;
begin
  GetMem(Buffer, BufSize);
  Count:=GetSystemDirectory(Buffer,BufSize);
  Result:=strpas(Buffer);
  FreeMem(Buffer, BufSize);
  Result:=TrailingBackSlash(Result);
end;

function TWindowsUserInfo.GetUserName:String;
begin
  Result:=fUserName^;
end;

function TWindowsUserInfo.GetCompanyName:String;
begin
  Result:=fCompanyName^;
end;

function TWindowsUserInfo.GetFreeSpace: longint;
begin
  Result:=WinProcs.GetFreeSpace(0);
end;


function TWindowsUserInfo.GetFreeGDI: integer;
begin
  Result:=GetFreeSystemResources(GFSR_GdiResources);
end;


function TWindowsUserInfo.GetFreeUser: integer;
begin
  Result:=GetFreeSystemResources(GFSR_UserResources);
end;


function TWindowsUserInfo.GetFreeSystem: integer;
begin
  Result:=GetFreeSystemResources(GFSR_SystemResources);
end;


{-----------------------------------------------------------------------------------------}
{ OBJECT FUNCTIONS                                                                        }
{-----------------------------------------------------------------------------------------}

Function TWindowsUserInfo.HasPassWord:Boolean;
begin
  Result:=fPassword^[0]>#0;
end;

Function TWindowsUserInfo.CheckPassWord(const Value:String):Boolean;
{can't be constant parameter as we use the buffer to do work with}
var
  Cursor:TCursor;
begin
  if HasPassWord then
    Result:= EncryptString(UpperCase(Value))=fPassWord^
  else
    Result:=True;
end;

function TWindowsUserInfo.GetUniqueFileName:String;
{this creates a file!}
{could/should add names to list and delete files on free}
var
  Buffer: PChar;
  Count: Word;
begin
  GetMem(Buffer, BufSize);
  Count:=GetTempFileName(#0,nil,0,Buffer);
  Result:=strpas(Buffer);
  FreeMem(Buffer, BufSize);
end;

{-----------------------------------------------------------------------------------------}
{ WINDOWS SCREENSAVER PASSWORD ENCRYPTION         REPACKAGED I HOPE I DONT GET SUED!      }
{-----------------------------------------------------------------------------------------}

procedure TWindowsUserInfo.WinEncrypt(Strg: PChar);
var
  StrgPt, Strglg : Integer;                                { Local Vars }
  TheByte : Byte;                                          { Working Char }

  procedure Exor (x1: byte; var x2: byte);
  const  { the last three are '[]=' - not allowed in profile string }
    NotAllowed = [0..$20, $7f..$90, $93..$9f, $3d, $5b, $5d];
  begin
    if not ((x2 xor x1) in NotAllowed) then
      x2 := x2 xor x1;
  end; { Exor }

begin
  StrgLg := lstrlen(Strg);                                 { Get String Length }
  if (StrgLg = 0) then exit;                               { empty string => nothing to do }
  AnsiUpper (Strg);                                        { capitalize the string }

  for StrgPt := 0 to StrgLg - 1 do begin                   { proceed from left to right }
    TheByte := byte (Strg [StrgPt]);                       { get character to encrypt }
    Exor (StrgLg, TheByte);                                { xor it using string length...}
    if (StrgPt = 0) then                                   { If EOS }
      Exor ($2a, TheByte)                                  {...a constant...}
    else begin
      Exor (StrgPt, TheByte);                              {...actual string pointer...}
      Exor (byte (Strg [StrgPt-1]), TheByte);              {...previous character }
      end;
    Strg [StrgPt] := char (TheByte);                       { store encrypted byte back }
    end; { for };

  if (StrgLg > 1) then                                     { no second pass for one-byte-strings }
    for StrgPt := StrgLg-1 downto 0 do begin               { proceed from right to left }
      TheByte := byte (Strg [StrgPt]);                     {  encrypt similar as in first pass }
      Exor (StrgLg, TheByte);                              { xor it using string length...}
      if (StrgPt = StrgLg - 1) then                        { If BOS }
        Exor ($2a, TheByte)                                {...a constant...}
      else begin
        Exor (StrgPt, TheByte);                            {...actual string pointer...}
        Exor (byte (Strg [StrgPt+1]), TheByte);            {...Next character }
        end;
      Strg [StrgPt] := char (TheByte);                     { store encrypted byte back }
      end; { for };
end;


Procedure TWindowsUserInfo.EncryptCString(S : PChar);
Begin
  WinEncrypt(S);
end;

Function TWindowsUserInfo.EncryptString(const S : String) : string;
begin
  Result := S;
  if Result[0] < #254 then begin
    Result[Integer(Result[0]) + 1] := Chr(0);
    WinEncrypt(@Result[1]);
    end;
end;

{-----------------------------------------------------------------------------------------}
{                                                                                         }
{-----------------------------------------------------------------------------------------}

end.